home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / pretty / test.ada < prev    next >
Encoding:
Text File  |  1996-01-30  |  1.8 KB  |  83 lines
  1. procedure display_menu (title:in string; options:in menus;
  2.  choice:out alpha_numerics) is
  3. left_column:constant:=15;
  4. right_column:constant:=20;
  5. prompt:constant string:=" ==> ";
  6.  
  7. type alpha_array is array(alpha_numerics) of boolean;
  8. valid:boolean;
  9. valid_option:alpha_array:=(others=>false);
  10.  
  11. procedure draw_menu(title:string;options:menus)is
  12. begin
  13. new_page;
  14. new_line;
  15. set_col(right_column);
  16. put_line(title);
  17. new_line;
  18. for choice in alpha_numerics loop
  19. if options(choice)/=empty_line then
  20. valid_option(choice):=true;
  21. set_col(left_column);
  22. put(choice&" -- ");
  23. put_line(options(choice));
  24. end if;
  25. end loop;
  26. end draw_menu;
  27.  
  28. procedure get_response(valid:out boolean;choice:out alpha_numerics) is
  29. buffer_size:constant:=20;
  30. dummy:constant alpha_numerics:='X';
  31. first_char:character;
  32. buffer:string(1..buffer_size);
  33. -- Notes
  34. --
  35. --
  36. last:natural;
  37. index:positive;
  38.  
  39. function upper_case(current_char:character)return character is
  40. case_difference:constant:=16#20#;
  41. begin
  42. if current_char in 'a'..'z' then
  43. return character'val (character'pos(current_char)-case_difference);
  44. else
  45. return current_char;
  46. end if;
  47. end upper_case;
  48.  
  49. begin -- get_response
  50.  new_line;
  51. set_col(left_column);
  52. put(prompt);
  53. get_line(buffer,last);
  54. index:=positive'first;
  55. loop
  56. exit when((index>= lst) or else (buffer(index) in alpha_numerics));
  57. index:=positive'succ(index);
  58. end loop;
  59. first_char:= upper_case(buffer(index));
  60. if (first_char not in alpha_numerics) or
  61. else(not valid_option(first_char)) then
  62. valid:=false;
  63. choice:=dummy;
  64. elsevalid:=true;
  65.  choice:=first_char;
  66. end if;
  67. end get_response;
  68.  
  69. procedure beep is
  70. begin
  71. put(ascii.bel);
  72. end beep;
  73.  
  74. begin
  75. loop
  76. draw_menu(title,options);
  77. get_response(valid,choice);
  78. exit when valid;
  79. beep;
  80. end loop;
  81. end display_menu;
  82.  
  83.